home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / DevTools / opt.f < prev    next >
Encoding:
FORTH Source  |  1991-11-15  |  12.9 KB  |  676 lines
  1. \ JForth Optimizing Compiler Extensions V1.0, Mike Haas, 12-May-90
  2. \ ----------------------------------------------------------------
  3. \
  4. \ 05/18/90 mdh     Version 1.0 to HMSL BBS
  5. \ 05/26/90 plb/mdh Added CELLS, check for "installed" on compile
  6. \ 05/29/90 mdh     Added CELL+, CELL-
  7. \ 06/07/90 mdh     Added 2* 2/
  8. \ 00005 06-aug-91  mdh     fixed Isconstant? (' SPACE would return -1)
  9. \ 00006 18-aug-91  mdh     Incorporated XBLK
  10. \ 00007 14-nov-91  mdh     added .need XBLK for older JF versions
  11.  
  12. exists? ifopt? .if
  13.     ifopt? .if
  14.         ." Optimizer on! Must be turned off before recompiling!" abort
  15.     .then
  16. .then
  17.  
  18. anew task-opt.f
  19.  
  20. .NEED XBLK   \ 00007
  21.    variable XBLK   XBLK off
  22. .THEN
  23.  
  24. variable MinOPTS   \ at least this many before optimization kicks in
  25. 3 MinOPTS !
  26. variable #Opts
  27.  
  28. \ -------------- identify words as optimizable...
  29.  
  30. .NEED OPT_BIT
  31. $ 80,0000 constant OPT_BIT
  32. .THEN
  33.  
  34. : SETOPT  ( cfa -- )
  35.   cell- dup @  OPT_BIT or swap !
  36. ;
  37.  
  38. : OPT_BIT?  ( cfa -- flag )
  39.   cell- @ opt_bit and
  40. ;
  41.  
  42. : EA,OP  ( reg opcode -- )  or w,  ;
  43.  
  44. : DN,OP  ( reg opcode -- )  swap 9 shift or w,  ;
  45.  
  46. : DN,EA,OP  ( regDN regEA opcode -- )
  47.   rot  9 shift  or  or  w,
  48. ;
  49.  
  50. 1 constant smallcon
  51. $ 7fff,ffff constant bigcon
  52.  
  53. : IsConstant?  ( cfa -- flag )
  54.   dup cell- @  bigcon and  dup
  55.   [ ' smallcon cell- @ bigcon and ] literal =
  56.   swap [ ' bigcon cell- @ bigcon and ] literal = or
  57.   IF
  58.      ( -- cfa )  \ 00005 start
  59.      dup @ $ ffff,ff00 and  [ ' smallcon @ $ ffff,ff00 and ] literal =
  60.      ( -- cfa flag )  over cell+ w@ $ 4e75 =  and ( -- cfa flag )
  61.      \
  62.      over @ [ ' bigcon @ ] literal =  ( -- cfa flag flag2 )
  63.      rot [ 2 cells ] literal +  w@ $ 4e75 = and ( -- cfa flag flag2 )
  64.      or  \ 00005 end
  65.   ELSE
  66.      drop false
  67.   THEN
  68. ;
  69.   
  70. \ -------------- the optimizing compiler words
  71.  
  72. 50 constant maxLITs   variable numLITs
  73. variable LITs         maxLITs 1- cells allot
  74. variable LitsDone
  75.  
  76. 5 constant numItems  \ number of data registers to cache
  77. 1 constant StartDataReg
  78.  
  79. variable NumCached
  80. numItems array theRegs
  81. numItems array RegUsed
  82.  
  83. \ normal    item0==tos  numCached == 1
  84.  
  85. : NumCached?  ( -- numCached )  numCached @  ;
  86.  
  87. : Reg>Index  ( reg -- ix )
  88.   dup 7 =
  89.   IF
  90.      drop 0
  91.   ELSE
  92.      StartDataReg - 1+
  93.   THEN
  94. ;
  95.  
  96. : Index>Reg  ( ix -- reg )
  97.   dup 0=
  98.   IF
  99.      drop 7
  100.   ELSE
  101.      1-  StartDataReg +
  102.   THEN
  103. ;
  104.  
  105. : MarkRegFree  ( reg -- )
  106.   Reg>Index RegUsed off
  107. ;
  108.  
  109. : GetFreeReg  ( -- reg# )  true
  110.   numItems 0 DO
  111.      i RegUsed @ 0=
  112.      IF
  113.         drop    i Index>Reg   i RegUsed on
  114.         false   leave
  115.      THEN
  116.   LOOP
  117.   IF
  118.      >newline ." Can't GetFreeReg; none left." quit
  119.   THEN
  120. ;
  121.  
  122. : NewReg  ( -- reg# )
  123.   GetFreeReg dup  numCached? theRegs !
  124.   1 numCached +!
  125. ;
  126.  
  127. : Item>Reg  ( stack-item-index -- register )
  128.   dup numCached @ 1- >  \ in range?
  129.   IF
  130.      >newline . ." too large.  Insufficient items cached" quit
  131.   ELSE
  132.      theRegs @
  133.   THEN
  134. ;
  135.  
  136. : EAToTOSReg  ( opcode -- )
  137.   0 Item>Reg swap ea,op
  138. ;
  139.  
  140. : CacheAnother  ( -- , load whatever is empty )
  141.   numCached @  numItems <
  142.   IF
  143.      NewReg  $ 201e  dn,op  \ move.l <dsp>+,dX
  144.   THEN
  145. ;
  146.  
  147. : LoadAtLeast  ( #regs -- )
  148.   dup numItems >
  149.   IF
  150.      >newline ." Can't LoadAtLeast " 0 .r ." ; numItems not high enough."
  151.      quit
  152.   THEN
  153.   dup numCached @ - 0>
  154.   IF
  155.      BEGIN  ( -- #regs )
  156.         CacheAnother  dup numCached @ <=
  157.      UNTIL
  158.   THEN
  159.   drop
  160. ;
  161.  
  162. : FlushLastItem  ( -- )
  163.   numCached? 1-  Item>Reg  dup MarkRegFree
  164.   $ 2d00  ea,op  \ move.l dX,-<dsp>
  165.   -1 numCached +!
  166. ;
  167.  
  168. : InitOpt  ( -- )
  169.   1 numCached !  0 RegUsed on   7 0 theRegs !
  170.   [ 1 RegUsed ] aliteral  [ numitems 1- cells ] literal erase
  171.   LitsDone off
  172. ;
  173.  
  174. : FlushRegs  ( -- , normalize registers )
  175.   numCached? ?dup
  176.   IF
  177.      1- dup 0
  178.      DO
  179.         ( -- last-index )  dup theRegs @
  180.         $ 2d00  ea,op  \ move.l dX,-<dsp>
  181.         1-
  182.      LOOP
  183.      drop
  184.      0 theRegs @ dup 7 -
  185.      IF
  186.         dup  $ 2e00  ea,op  \ move.l dX,tos
  187.      THEN
  188.      drop
  189.   ELSE
  190.      compile drop
  191.   THEN
  192.   InitOpt
  193. ;
  194.  
  195. : DropFromCnt  ( from cnt -- , drop FROM cell COUNT cells )
  196.   2dup +   numCached @ >
  197.   IF
  198.      >newline ." Can't DropFromCount; invalid parameters: " swap . . quit
  199.   THEN
  200.   >r
  201.   cells  0 theRegs  +   ( to-addr )
  202.   dup r@ 0 DO
  203.      dup @ MarkRegFree   cell+
  204.   LOOP
  205.   drop
  206.   dup r@ cells +  tuck  ( from to from )
  207.   0 theRegs  numCached @ cells   +   - abs   move
  208.   r> negate numCached +!
  209. ;
  210.  
  211. : FreeTOS  ( -- , open up space )
  212.   \ do we have to push out a regs?
  213.   numCached? numItems =
  214.   IF
  215.      FlushLastItem
  216.   THEN
  217.   0 theRegs  1 theRegs  [ numItems 1- cells ] literal  move
  218.   1 numCached +!
  219. ;
  220.  
  221. : Get1For2  ( If1Opcode If2Opcode -- )
  222.   1 LoadAtLeast
  223.   numCached @ 1 =
  224.   IF
  225.      0 Item>Reg   2 pick  dn,op  \ ???.l (dsp)+,dx
  226.   ELSE
  227.      0 Item>Reg  1 Item>Reg   2 pick   ( ???.l dX,dY ) dn,ea,op
  228.      1 1 DropFromCnt
  229.   THEN
  230.   2drop
  231. ;
  232.  
  233. : O.+  ( -- )
  234.    $ d09e   $ d080   Get1For2
  235. ;
  236. ' + setopt
  237.  
  238. : O.-  ( -- )
  239.   2 LoadAtLeast
  240.   1 Item>Reg  0 Item>Reg  $ 9080  ( sub.l dX,dY )  dn,ea,op
  241.   0 1 DropFromCnt
  242. ;
  243. ' - setopt
  244.  
  245. : O.drop   ( -- )
  246.   numCached?
  247.   IF
  248.      0 1 DropFromCnt
  249.   ELSE
  250.      $ 588e w,   \ addq.l  #4,a6
  251.   THEN
  252. ;
  253. ' drop setopt
  254.  
  255. : O.swap  ( -- )
  256.   2 LoadAtLeast
  257.   0 theRegs @
  258.   1 theRegs @ 0 theRegs !
  259.   1 theRegs !
  260. ;
  261. ' swap setopt
  262.  
  263. : O.dup  ( -- )
  264.   numCached?
  265.   FreeTOS
  266.   GetFreeReg  dup 0 theRegs !  swap  ( -- reg numC )
  267.   IF
  268.      1 theRegs @  $ 2000  dn,ea,op  \ move dX,dY
  269.   ELSE
  270.      $ 2016 dn,op
  271.   THEN
  272. ;
  273. ' dup setopt
  274.  
  275. : O.rot  ( -- )
  276.   3 LoadAtLeast
  277.   2 Item>Reg    0 Item>Reg    1 Item>Reg   ( -- r2 r0 r1 )
  278.   2 theRegs !   1 TheRegs !   0 theRegs !
  279. ;
  280. ' rot setopt
  281.  
  282. : O.-rot  ( -- )
  283.   3 LoadAtLeast
  284.   0 Item>Reg    1 Item>Reg    2 Item>Reg   ( -- r0 r1 r2 )
  285.   1 theRegs !   0 TheRegs !   2 theRegs !
  286. ;
  287. ' -rot setopt
  288.  
  289. : DoToTOS  ( opcode -- )
  290.   numCached?
  291.   IF
  292.      EAToTOSReg  \ xxxq.l #?,dx
  293.   ELSE
  294.      $ ff00 and  $ 96 or w,     \ xxxq.l #?,(dsp)
  295.   THEN
  296. ;
  297.  
  298. : O.1+  ( -- )
  299.   $ 5280  DoToTOS   \ addq.l #1,dx
  300. ;
  301. ' 1+ setopt
  302.  
  303. : O.1-
  304.   $ 5380  DoToTOS   \ subq.l #1,dx
  305. ;
  306. ' 1- setopt
  307.  
  308. : O.2+
  309.   $ 5480  DoToTOS   \ addq.l #2,dx
  310. ;
  311. ' 2+ setopt
  312.  
  313. : O.2-
  314.   $ 5580  DoToTOS   \ subq.l #2,dx
  315. ;
  316. ' 2- setopt
  317.  
  318. : O.CELL+  ( -- )
  319.   $ 5880  DoToTOS   \ addq.l #4,dx
  320. ;
  321. ' cell+ setopt
  322.  
  323. : O.CELL-
  324.   $ 5980  DoToTOS   \ subq.l #4,dx
  325. ;
  326. ' cell- setopt
  327.  
  328. : O.cells
  329.     1 LoadAtLeast
  330.     $ E580 EAToTOSReg
  331. ;
  332. ' cells setopt
  333.  
  334. : O.i  ( -- )
  335.   FreeTOS
  336.   GetFreeReg  dup 0 theRegs !
  337.   dup  $ 2005  dn,op  \ move d5,dx
  338.   $ d086  dn,op       \ add d6,dx
  339. ;
  340. ' i setopt
  341.  
  342. : O.c@
  343.   1 LoadAtLeast
  344.   FreeTOS
  345.   GetFreeReg  dup 0 theRegs !
  346.   dup $ 7000  dn,op   ( -- 0reg )  \ moveq #0,dx
  347.   $ 1034 dn,op  1 Item>Reg  12 shift $ 0800 or w,  \ move.b 0(a4,dy.l),dx
  348.   1 1 DropFromCnt
  349. ;
  350. ' c@ setopt
  351.  
  352. : O.@
  353.   1 LoadAtLeast
  354.   0 Item>Reg  dup $ 2034 dn,op
  355.   12 shift $ 0800 or w,          \ move.l 0(a4,dx.l),dx
  356. ;
  357. ' @ setopt
  358.  
  359. : O.over ( -- )
  360.   numCached?
  361.   FreeTOS
  362.   GetFreeReg  dup 0 theRegs !  swap   ( -- reg #C )  ?dup
  363.   IF
  364.      1 =
  365.      IF
  366.         $ 2016  dn,op   \ move.l  (dsp),dx
  367.      ELSE
  368.         2 Item>Reg  $ 2000  dn,ea,op  \ move dX,dY
  369.      THEN
  370.   ELSE
  371.      $ 202e  dn,op 4 w,  \ move.l 4(dsp),dx
  372.   THEN
  373. ;
  374. ' over setopt
  375.  
  376. : o.2dup
  377.   o.over  o.over
  378. ;
  379. ' 2dup setopt
  380.  
  381. : O.c!
  382.   2 LoadAtLeast
  383.   1 Item>Reg  $ 1980 ea,op
  384.   0 Item>Reg  12 shift  $ 0800 or  w,  \ move.b dx,0(a4,dy.l)
  385.   0 2 DropFromCnt
  386. ;
  387. ' c! setopt
  388.  
  389. : O.!
  390.   2 LoadAtLeast
  391.   1 Item>Reg  $ 2980 ea,op
  392.   0 Item>Reg  12 shift  $ 0800   or w,  \ move dx,0(a4,dy.l)
  393.   0 2 DropFromCnt
  394. ;
  395. ' ! setopt
  396.  
  397. : O.2drop
  398.   numCached? ?dup
  399.   IF
  400.      1 =
  401.      IF
  402.         0 1 DropFromCnt
  403.         $ 588e w,  \ addq.l  #4,dsp
  404.      ELSE
  405.         0 2 DropFromCnt
  406.      THEN
  407.   ELSE
  408.      $ 508e w,  \ addq.l  #8,dsp
  409.   THEN
  410. ;
  411. ' 2drop setopt
  412.  
  413. : O.>r
  414.   numCached?
  415.   IF
  416.      $ 2f00  EAToTOSReg    \ move dx,-(rp)
  417.      0 1 DropFromCnt
  418.   ELSE
  419.      $ 2f1e w,  \ move.l (dsp)+,-(rp)
  420.   THEN
  421. ;
  422. ' >r setopt
  423.  
  424. : O.r>
  425.   FreeTOS
  426.   GetFreeReg  dup 0 theRegs !   $ 201f  dn,op    \ move (rp)+,dx
  427. ;
  428. ' r> setopt
  429.  
  430. : o.r@
  431.   FreeTOS
  432.   GetFreeReg  dup 0 theRegs !   $ 2017  dn,op    \ move (rp),dx
  433. ;
  434. ' r@ setopt
  435.  
  436. : O.lit  ( -- )
  437.   LitsDone @ cells LITs + @  ( -- val )
  438.   FreeTOS
  439.   GetFreeReg  0 theRegs !
  440.   dup -128 127 within?
  441.   IF
  442.      $ ff and  $ 7000 or   0 Item>Reg swap  dn,op
  443.   ELSE
  444.      0 Item>Reg  $ 203c  dn,op  ,
  445.   THEN
  446.   1 LitsDone +!
  447. ;
  448. ' literal setopt
  449.  
  450. : O.and  ( -- )
  451.   $ c09e  $ c080  Get1For2
  452. ;
  453. ' and setopt
  454.  
  455. : O.or  ( -- )
  456.   $ 809e  $ 8080  Get1For2
  457. ;
  458. ' or setopt
  459.  
  460. : O.nip  ( -- )
  461.   numCached? ?dup
  462.   IF
  463.      1 >
  464.      IF
  465.         1 1 DropFromCnt
  466.      ELSE
  467.         $ 588e w,  \ addq.l  #4,dsp
  468.      THEN
  469.   ELSE
  470.      FreeTOS GetFreeReg  dup 0 theRegs !
  471.      $ 2016 dn,op  \ move.l  (dsp),dx
  472.      $ 508e w,  \ addq.l  #8,dsp
  473.   THEN
  474. ;
  475. ' nip setopt
  476.  
  477. : o.2*  ( -- )
  478.   1 LoadAtLeast
  479.   0 Item>reg dup  $ d080  dn,ea,op    \ add.l dx,dx
  480. ;
  481. ' 2* setopt
  482.   
  483. : o.2/  ( -- )
  484.   1 LoadAtLeast
  485.   $ e280 EAToTOSReg   \ asr.l  #1,dx
  486.   $ 6a04 w,           \ bpl  *+6
  487.   $ 6402 w,           \ bpl  *+4
  488.   $ 5280 EAToTOSReg   \ addq.l #1,dx
  489. ;
  490. ' 2/ setopt
  491.  
  492.  
  493. \ -------------- the optimizer's "compilation stack"
  494.  
  495. 50 constant maxOPTs   variable numOPTs
  496. variable OPTs         maxOPTs 1- cells allot
  497.  
  498. : FlushOPTs  ( -- , do all optimized compilation & flush regs )
  499.   numOPTs @  ?dup
  500.   IF
  501.      dup MINOPTS @ >=
  502.      IF
  503. \ >newline ." Flushing OPTs..." cr
  504.         \ worth doing optimization
  505.         InitOpt  ( -- numOPTs )  0
  506.         DO
  507.            i cells  OPTs + @   ( -- cfa )
  508.            CASE
  509. \
  510.               ' +     OF O.+     ENDOF
  511.               ' -     OF O.-     ENDOF
  512.               ' drop  OF O.drop  ENDOF
  513.               ' swap  OF O.swap  ENDOF
  514.               ' dup   OF O.dup   ENDOF
  515.               ' rot   OF O.rot   ENDOF
  516.               ' 1+    OF O.1+    ENDOF
  517.               ' 2+    OF O.2+    ENDOF
  518.               ' 1-    OF O.1-    ENDOF
  519.               ' 2-    OF O.2-    ENDOF
  520.               ' i     OF O.i     ENDOF
  521.               ' @     OF O.@     ENDOF
  522.               ' c@    OF O.c@    ENDOF
  523.               ' over  OF O.over  ENDOF
  524.               ' 2dup  OF O.2dup  ENDOF
  525.               ' c!    OF O.c!    ENDOF
  526.               ' !     OF O.!     ENDOF
  527.               ' 2drop OF O.2drop ENDOF
  528.               ' >r    OF O.>r    ENDOF
  529.               ' r>    OF O.r>    ENDOF
  530.               ' r@    OF O.r@    ENDOF
  531.             ' literal OF O.lit   ENDOF
  532.               ' -rot  OF O.-rot  ENDOF
  533.               ' and   OF O.and   ENDOF
  534.               ' or    OF O.or    ENDOF
  535.               ' nip   OF O.nip   ENDOF
  536.               ' cell+ OF O.cell+ ENDOF
  537.               ' cell- OF O.cell- ENDOF
  538.               ' cells OF O.cells ENDOF
  539.               ' 2*    OF O.2*    ENDOF
  540.               ' 2/    OF O.2/    ENDOF
  541.  
  542. \
  543.               >newline ." Illegal CFA found in optimization stack." quit
  544.            ENDCASE
  545.            1 #Opts +!
  546.         LOOP
  547.         FlushRegs
  548.      ELSE
  549.         InitOpt   0 DO
  550.            i cells OPTs + @ dup ' literal =
  551.            IF
  552.               drop
  553.               LitsDone @ cells LITs + @  ( -- val ) [compile] literal
  554.               1 LitsDone +!
  555.            ELSE
  556.               cfa,
  557.            THEN
  558.         LOOP
  559.      THEN
  560.      numOPTs off  numLITs off
  561.   THEN
  562. ;
  563.  
  564.  
  565. : >OPTs  ( cfa -- )
  566.   numOPTs @ maxOPTs >=
  567.   IF
  568.      FlushOPTs
  569.   THEN
  570.   OPTs numOPTs @ cells +  !
  571.   1 numOPTs +!
  572. ;
  573.  
  574. : >LITs  ( n1 -- )
  575.   numLITs @ maxLITs >=
  576.   IF
  577.      FlushOPTs
  578.   THEN
  579.   ' literal >OPTs
  580.   LITs numLITS @ cells +  !
  581.   1 numLITs +!
  582. ;
  583.  
  584.  
  585. \ -------------- the new optimizing INTERPRET vector
  586.  
  587. : INTERPRET.O  ( -- , optimizing INTERPRET )
  588.   TIBEND off
  589.   BEGIN
  590.      bl word find dup       ( -- ?? flag flag )
  591.      IF
  592.         ( -- cfa flag )  STATE @
  593.         IF
  594.            0<     ( -- cfa flag )
  595.            IF
  596.               dup OPT_BIT?
  597.               IF
  598.                  >OPTs
  599.               ELSE
  600.                  dup IsConstant?  numOPTs @ and
  601.                  IF
  602.                     execute >LITs
  603.                  ELSE
  604.                     FlushOPTs  cfa,
  605.                  THEN
  606.               THEN
  607.            ELSE
  608.               here w@ dup $ 015c =  swap $ 0128 = or 0=
  609.               IF
  610.                  FlushOPTs
  611.               THEN
  612.               execute ?stack
  613.            THEN
  614.         ELSE
  615.            drop execute ?stack
  616.         THEN
  617.         0    ( -- notagainflag )
  618.      ELSE
  619.         ( -- here 0 )  2drop   TIBEND @
  620.         IF
  621.            FBLK @ 0=     XBLK @ 0= and ( 00006 )
  622.         ELSE
  623.            here number  dpl @ 1+   ( -- d1 dpl+1 )  \ FlushOPTs
  624.            IF
  625.               FlushOPTs  [compile] dliteral
  626.            ELSE
  627.               drop  numOPTs @
  628. \ dup >newline ." numOPTs = " . cr
  629.               IF
  630.                  >LITs
  631.               ELSE
  632.                  FlushOPTs  [compile] literal
  633.               THEN
  634.            THEN
  635.            ?stack  0
  636.         THEN
  637.      THEN
  638.   UNTIL
  639. ;
  640.  
  641.  
  642. variable Pre-Opt-Interpret  variable Pre-Opt-quit
  643.  
  644. : IfOpt?  ( -- flag )
  645.     what's interpret ' interpret.o =
  646. ;
  647.  
  648. : OptQuit  numOPTs off numLITs off  InitOpt  Pre-Opt-Quit @execute  ;
  649.  
  650. : OPTON  ( -- , install optimizer )
  651.   ifopt?
  652.   IF
  653.      >newline ." Optimizer already installed" cr
  654.   ELSE
  655.      what's interpret Pre-Opt-Interpret !
  656.      ' interpret.o is interpret
  657.      what's quit Pre-Opt-Quit !  ' OptQuit is quit
  658.   THEN
  659. ;
  660.  
  661. : OPT  OptOn ;
  662.  
  663. : OPTOFF  ( -- , UNinstall optimizer )
  664.   what's interpret  ' interpret.o -
  665.   IF
  666.      >newline ." Optimizer not installed" cr
  667.   ELSE
  668.      Pre-Opt-Interpret @ is interpret
  669.      Pre-Opt-Quit @ is quit
  670.   THEN
  671. ;
  672.  
  673. : NoOPT  OptOff ;
  674.  
  675. if.forgotten OPTOFF
  676.